#light  
namespace Demos.ParserWeb

(* Uncomment this to get intelisense in VS
#I "..\\Bin"
#r "webtools.core.dll"
#r "webtools.controls.dll"
//*)

open System
open System.IO
open System.Web
open System.Drawing
open System.Collections.Generic
open FSharp.WebTools
open FSharp.WebTools.Core

// ----------------------------------------------------------------------------
// F# data types

type Token =
  | TLBrace
  | TRBrace 
  | TComma
  | TOperator of char
  | TIdentifier of string
  | TNumber of float

type State =
  | TSNone
  | TSNumber of string
  | TSIdent of string

type AstNode = 
  | Number of float
  | Var of string
  | Binary of char*AstNode*AstNode
  | Unary of char*AstNode
  | Function of string*(AstNode list)

type Operator = 
  | OpSym of char 
  | OpFun of string

type Env = 
  { Nodes:Stack<AstNode>; 
    Operators:Stack<Operator>; 
    LastIdent:bool; }

type PrettyPrintRes = 
  { Out:string; 
    BraceIndex:int; 
    Depth:int }
    

/// This type uses only side-neutral types and can be executed on both
/// client-side (in JavaScript) and server-side (in F#/IL)
[<NeutralSide>]
type Parsing = 

  // --------------------------------------------------------------------------
  // Pretty printing - generates HTML code

  [<ReflectedDefinition>]
  static member PrettyPrint (nd) = 
    let max (a:int) (b:int) = 
      if (a>b) then a else b  
      
    let rec wrapNTimes (s:string) n wpre wpost = 
      match n < 1 with
      | true -> s
      | false -> wpre + (wrapNTimes s (n-1) wpre wpost) + wpost      
      
    let getUnaryOpPrec = function 
      | '-' -> 4
      | _ -> failwith "getUnaryOpPrec"      
      
    let getBinaryOpPrec = function
      | '^' -> 1
      | '*' | '/' -> 2
      | '+' | '-' -> 3
      | _ -> failwith "getBinaryOpPrec"
      
    let wrapInBraces wrap v depth wrapTd = 
      let tds, tdf = if wrapTd then "<td>", "</td>" else "", ""
      if wrap then 
        "<td>" + (wrapNTimes "(" (depth-1) "<span class=\"nlb\">" "</span>") + 
        "</td>" + tds + v + tdf + "<td>" + 
        (wrapNTimes ")" (depth-1) "<span class=\"nlb\">" "</span>") + "</td>"
      else 
        tds + v + tdf
        
    let renderFunc f str d =
      { Out="<table class=\"fnc\"><tr><td>" + f + 
            "</td>" + str + "</tr></table>";
        BraceIndex=0; Depth=d; }

    let rec printArgs a =
      match a with 
      | x::[] -> let o = prettyPrint x in ("<td>" + o.Out + "</td>", o.Depth)
      | x::xs -> 
          let (sa, hn) = printArgs(xs)
          let ox = prettyPrint(x)
          ("<td>" + ox.Out + "</td><td>,</td>" + sa, max hn ox.Depth)
      | [] -> "", 1
    
    and prettyPrint nd =  
      match nd with 
        | Number n -> 
            { Out="<span class=\"n\">" + n.ToString() + "</span>";
              BraceIndex=(if (n<0.0) then 4 else 0); Depth=1 }
        | Unary (op, e) ->
            let v = prettyPrint e
            let bi = getUnaryOpPrec op
            { Out="<table class=\"op\"><tr><td>" + op.ToString() + "</td>" +
                  (wrapInBraces (v.BraceIndex > bi) v.Out v.Depth true) + 
                  "</tr></table>"; 
                BraceIndex=bi; Depth=v.Depth }
        | Binary (op, l, r) ->
            let lv, rv = prettyPrint l, prettyPrint r
            if (op = '/') then
              { Out="<table class=\"op_d\"><tr><td class=\"op_d1\">" + lv.Out +
                    "</td></tr><tr><td class=\"op_d2\">" + rv.Out + 
                    "</td></tr></table>";
                BraceIndex=0; Depth=(lv.Depth + rv.Depth) }
            else
              let bi = getBinaryOpPrec op
              let n  = max lv.Depth rv.Depth
              { Out="<table class=\"op\"><tr>" + 
                    (wrapInBraces (lv.BraceIndex > bi) lv.Out n true) + 
                    "<td>" + op.ToString() + "</td>" +
                    (wrapInBraces (rv.BraceIndex > bi) rv.Out n true) + 
                    "</tr></table>"; 
                BraceIndex=bi; Depth=n }
        | Var v -> 
            let und = v.IndexOf("_")
            let v = 
              if und = -1 then v else
                v.Substring(0, und)+"<sub>" + 
                v.Substring(und+1, v.Length-und-1)+"</sub>"
            { Out="<span class=\"var\">" + v + "</span>"; 
              BraceIndex=0; Depth=1; }
        | Function(f,a) -> 
            if (f = "sqrt" && (List.length a) = 1) then 
              match a with
              | [oa] -> 
                  let arg = (prettyPrint oa)
                  let f = 
                    wrapNTimes "&#8730;" (arg.Depth-1) 
                               "<span class=\"nrt\">" "</span>"
                  let sarg = 
                    wrapInBraces (arg.BraceIndex > 0) 
                                 arg.Out arg.Depth true
                  renderFunc f sarg arg.Depth
              | _ -> failwith "!"
            else 
              let (args,n) = printArgs a
              renderFunc f (wrapInBraces true args n false) n
    // drop temp info            
    (prettyPrint nd).Out

  // --------------------------------------------------------------------------
  // Simplification - perform some elementary simplification of the expression
    
  [<ReflectedDefinition>]
  static member Simplify (nd) = 
    
    let rec minus e =
      match e with
      | Unary(op, ne) -> if (op = '-') then ne else Unary('-', e)
      | Number(n) -> Number (-n)
      | Binary(op,l,r) -> 
          match op with
          | '*' -> Binary(op, minus l, r)
          | '/' -> Binary(op, minus l, r)
          | '+' -> Binary(op, minus l, minus r)
          | '-' -> Binary('+', l, minus r)
          | _ ->   Unary('-', e)
      | Var(v) -> Unary('-', e)
      | Function(f,a) -> Unary('-', e)
    
    let rec collapseAssoc oparg c f =
      match oparg with 
      | Binary(c1,l,r) when c1 = c ->
          match l,r with 
          | Number(a), Number(b) -> Number(f a b)
          | a, Number(b) -> collapseAssoc (Binary(c, Number b, a)) c f
          | Number(a), Binary(c1, Number(b), r)
          | Binary(c1, Number(a), r), Number(b) when c1 = c -> 
              Binary(c, Number(f a b), r)
          | Binary(c1, Number(n), a), Binary(c2, Number(m), b) 
              when c1=c && c2=c -> 
              Binary(c, Number(f n m), Binary(c, a, b))
          | Binary(c1, Number(n), a), b 
          | a, Binary(c1, Number(n), b) when c1=c -> 
              Binary(c, Number(n), Binary(c, a, b))
          | _ -> oparg
      | _ -> oparg
    
    let rec simplifyOp r = 
      let r = collapseAssoc r '+' (fun a b -> a + b)
      let r = collapseAssoc r '*' (fun a b -> a * b)
      match r with 
        | Binary('*', Number n, a) -> 
            if (n = 0.0) then (Number 0.0) 
            elif (n = 1.0) then a else r
        | Binary('+', Number n, a) -> 
            if (n = 0.0) then a else r
            
        | Binary('/', a, Binary('/', b, c)) ->
            Binary('/', simplifyOp (Binary('*', a, c)), b)
        | Binary('/', Binary('/', a, b), c) ->
            Binary('/', a, simplifyOp (Binary('*', c, b)))
        | Binary('/', Number a, x) when a = 0.0 -> Number(0.0)
        | Binary('/', x, Number a) when a = 1.0 -> x
        | Binary('/', Number a, Number b) -> Number(a/b)
        
        | Binary('^', Number a, Number b) -> Number(Math.Pow(a,b))
        | Binary('^', a, Number n) when n = 0.0 -> Number(1.0)
        |   Binary('^', a, Number n) when n = 1.0 -> a
        
        | _ -> r
      
    and simplify nd = 
      match nd with 
      | Unary (op, e) when op = '-' -> minus (simplify e)
      | Unary (op, e) -> nd
      | Number (n) -> Number n
      | Binary (op, l, r) ->
          let op, el, er = 
            if op = '-' then ('+', simplify l, simplify (minus r)) 
              else op, simplify l, simplify r
          simplifyOp (Binary(op,el,er))
      | Var v -> Var v
      | Function(f,args) -> 
          let args = List.map simplify args
          match args with
          | [Number(n)] when f = "sqrt" -> Number(Math.Sqrt(n))
          | _ -> Function(f, args)
    simplify nd

  // --------------------------------------------------------------------------
  // Get variables - returns names of all variables in the expression

  [<ReflectedDefinition>]
  static member GetVariables (ast) =     
    let rec getVars ast (list:ResizeArray<string>) = 
      match ast with
      | Unary (_, e) -> getVars e list
      | Number (n) -> ();
      | Binary (op, l, r) -> getVars l list; getVars r list
      | Var v -> if not (list.Contains(v)) then list.Add(v)
      | Function(f,args) -> List.iter (fun a -> getVars a list ) args
    let l = (new ResizeArray<string>())
    getVars ast l;
    l

  // --------------------------------------------------------------------------
  // Differentiation - symbolic differentiation of the expression
    
  [<ReflectedDefinition>]
  static member Differentiate (ast, vn) =     
    let rec diff nd =
      match nd with
      | Var(v) -> if (v <> vn) then Number(0.0) else Number(1.0)
      | Number(_) -> Number(0.0)
      | Unary('-', f) -> Unary('-', diff f)
      | Binary(c, f, g) when c='+' || c='-' -> Binary(c, diff f, diff g)
      | Binary('*', f, g) -> 
          Binary('+', Binary('*', diff f, g), Binary('*', f, diff g))
      | Binary('/', f, g) -> 
          Binary('/', 
                 Binary('-', Binary('*', diff f, g), Binary('*', f, diff g)), 
                 Binary('^', g, Number(2.0)))
      | Binary('^', f, Number(p)) -> 
          Binary('*', Binary('*', Number(p), 
                             Binary('^', f, Number(p - 1.0))), diff f)
      | Function(f, args) ->
          match args with
          | [a] when f="sqrt" -> 
              diff (Binary('^', a, Number(0.5)))
          | [a] when f="sin"  -> 
              Binary('*', Function("cos", [a]), diff a)
          | [a] when f="cos"  -> 
              Binary('*', Binary('-', Number(0.0), 
                                 Function("sin", [a])), diff a)
          | [a] -> Binary('*', Function(f+"'", [a]), diff a)
          | _ -> Function("diff", [nd])
      | _ -> Function("diff", [nd])
    diff ast

  // --------------------------------------------------------------------------
  // Evaluation - takes function that returns values of variables

  [<ReflectedDefinition>]
  static member Evaluate (nd, varfunc:string->float) = 
    let rec eval nd =
      match nd with
      | Var(v) -> varfunc v
      | Number(n) -> n
      | Unary(c, f) -> 
          if (c = '-') then -(eval f) else failwith "unknown unary"
      | Binary(c, f, g) ->
          let ef, eg = eval f, eval g
          match c with 
          | '+' -> ef + eg
          | '*' -> ef * eg
          | '/' -> ef / eg 
          | '-' -> ef - eg
          | '^' -> Math.Pow(ef,eg)
          | _ -> failwith "unknown binary"
      | Function(f, args) ->
          match args with
          | [a] when f="sqrt" -> Math.Sqrt(eval a);
          | [a] when f="sin"  -> Math.Sin(eval a);
          | [a] when f="cos"  -> Math.Cos(eval a);
          | _ -> failwith "unknown function"
    eval nd

  // --------------------------------------------------------------------------
  // Parsing - transforms list of tokens to the AST
    
  [<ReflectedDefinition>]
  static member Parse (toks) =     
    let getOpPriority c =
      match c with 
      | '^' -> 3
      | '*' | '/' -> 2
      | '+' | '-' -> 1
      | _ -> failwith "Unknown operator!"

    let isBinOp c = (c <> ',') && (c <> '(')

    let setLastIdent env b =
      { env with LastIdent=b; }
    
    let pushComma (env:Env) =
      env.Operators.Push(OpSym ',');
      setLastIdent env false
        
    let pushNode (env:Env) n =
      env.Nodes.Push(n);
      let li = match n with Var(_) -> true | _ -> false
      setLastIdent env li

    let pushLBrace (env:Env) =
      if (env.LastIdent) then
        match env.Nodes.Pop() with
        | Var(n) -> env.Operators.Push(OpFun n);
        | _ -> failwith "yikes!"
      else
        env.Operators.Push(OpSym '(');
      setLastIdent env false

    let rec pushBinOp (env:Env) op =
      match env.Operators.Peek() with
      | OpSym pop when (isBinOp pop) && ((getOpPriority pop) >= (getOpPriority op)) ->
          ignore (env.Operators.Pop())
          let r,l = env.Nodes.Pop(),env.Nodes.Pop()
          env.Nodes.Push(Binary(pop, l, r))
          pushBinOp env op
      | _ ->
          env.Operators.Push(OpSym op);
          setLastIdent env false
          
    let getOneNode (s:AstNode list) =
      match s with
      | [a] -> a
      | _ -> failwith "noo";
      
    let pushRBrace (env:Env) =
      let rec popRB s =
        let op = env.Operators.Pop()
        match op, s with
        | OpSym '(', [nd] -> env.Nodes.Push(nd)
        | OpSym ',', _    -> popRB ((env.Nodes.Pop())::s)
        | OpFun c, _ -> env.Nodes.Push(Function(c,s))
        | OpSym c, x::xs when isBinOp c -> popRB ((Binary(c, env.Nodes.Pop(), x))::xs)
        | OpSym c, _ -> failwith ("Whoops! "+c.ToString()+" : "+s.ToString())
        | _ -> failwith "No way..."
      popRB [env.Nodes.Pop()]
      setLastIdent env false

    let rec parse env tl =
      match tl with 
      | x::xs ->
          let env =
            match x with 
              | TNumber n -> pushNode env (Number n) 
              | TOperator op -> pushBinOp env op 
              | TLBrace -> pushLBrace env
              | TRBrace -> pushRBrace env
              | TIdentifier s -> pushNode env (Var s)
              | TComma -> pushComma env
          parse env xs
      | [] -> env
            
    let env = { Nodes=new Stack<_>(); Operators=new Stack<_>(); LastIdent=false; }
    let env = parse env ((TLBrace::toks)@[TRBrace])
    if (env.Operators.Count <> 0 || env.Nodes.Count <> 1) then failwith "!"
    env.Nodes.Pop();

  // --------------------------------------------------------------------------
  // Lexing - generates tokens from the string
    
  [<ReflectedDefinition>]
  static member Tokenize (s:string) =        
    let ca = s.ToCharArray();
    
    // character constants
    let zcd,ncd = Char.code('0'), Char.code('9')
    let lacd,lzcd = Char.code('a'), Char.code('z')
    let uacd,uzcd = Char.code('A'), Char.code('Z')

    // numbers & identifiers - tests & conversions
    let isNum c = ((Char.code(c) >= zcd) && (Char.code(c) <= ncd)) || c = '.'
    let isIdent c = 
      (Char.code(c) >= lacd) && (Char.code(c) <= lzcd) || 
      (Char.code(c) >= uacd) && (Char.code(c) <= uzcd) || c = '_'

    let ident s =        TIdentifier s
    let num (n:string) = TNumber(Double.Parse(n))

    // process one char from the string, returns created tokens and state
    //  * st - current state, 
    //  * i - current index
    //  * finalize - func. returning previous token (number/string) when needed
    let takeChar st i finalize =
      let cs = ca.[i].ToString()
      match ca.[i] with
      | ' ' | '\t' -> TSNone, (finalize())
      | ',' -> TSNone, (finalize())@[TComma]
      | '(' -> TSNone, (finalize())@[TLBrace]
      | ')' -> TSNone, (finalize())@[TRBrace]
      | '*' | '+' | '/' | '-' | '^' -> TSNone, (finalize())@[TOperator(ca.[i])]
      | c when isNum(c) ->
          match st with 
            | TSNone -> TSNumber(cs), []
            | TSNumber(n) -> TSNumber(n + cs), []
            | TSIdent(n) -> TSIdent(n + cs), []
      | c when isIdent(c) ->
          match st with
            | TSNone -> TSIdent(cs), []
            | TSNumber(n) -> failwith "Identifier can't start with number!"
            | TSIdent(n) -> TSIdent(n + cs), []
      | _ -> failwith "Unexpected character!"
      
    let rec tok st i =
      if (i = ca.Length) then 
        match st with
        | TSNone        -> []
        | TSNumber(n)   -> [num n]
        | TSIdent(n)    -> [ident n]
      else
        let nst,t =
          match st with
          | TSNone         -> takeChar st i (fun () -> []);
          | TSNumber(n)    -> takeChar st i (fun () -> [num n])
          | TSIdent(n)     -> takeChar st i (fun () -> [ident n])
        t@(tok nst (i + 1))
    tok TSNone 0



// ----------------------------------------------------------------------------
// This is server-side only class that renders an image

type Renderer = 

  // Renders image on the server and saves it in the App_Data folder
  static member Render (ast, rfrom, rto) =
    let wid, hgt = 300.0, 200.0
    let bmp = new Bitmap(int wid, int hgt)
    let r = new Random()
    using (Graphics.FromImage(bmp)) (fun gr ->
      let first = (Parsing.Evaluate(ast, fun n -> if (n="x") then rfrom else 0.0))
      let min, max = ref first, ref first
      for i = 1 to 300 do
        let pos = rfrom + (rto - rfrom)/300.0*(float i)
        let n = (Parsing.Evaluate(ast, fun n -> if (n="x") then pos else 0.0))
        if (n < !min) then min := n
        if (n > !max) then max := n
      let q = - (hgt / (float (!max - !min)))
      let shift = -q*(!min) + hgt
      let step = wid / 300.0
        
      let prev = ref (first*q + shift)
      for i = 1 to 300 do
        let pos = rfrom + (rto - rfrom)/300.0*(float i)
        let n = shift + q*(Parsing.Evaluate(ast, fun n -> if (n="x") then pos else 0.0))
        gr.DrawLine(Pens.DarkGreen, int (float (i-1)*step), int (!prev), int (float i*step), int n)
        prev := n )
    let name = Guid.NewGuid().ToString("D")
    bmp.Save(HttpContext.Current.Server.MapPath("~/App_Data/"+name+".png"))
    name